perm filename TASTER.SAI[1,LES]1 blob
sn#006738 filedate 1973-01-25 generic text, type T, neo UTF8
00100 BEGIN "TASTER - L. Earnest, December 1971"
00200 REQUIRE "GOOD.SAI[1,LES]" SOURCE_FILE;
00300
00400 DEFINE WMAX="40"; ⊂ max. number of wines;
00500 DEFINE PMAX="40"; ⊂ max. number of people;
00600 DEFINE INST="""TASTER.LES[W,LES]"""; ⊂ program documentation;
00700
00800 INTEGER W,SCALE,I;
00900 STRING S,T,FILE,DATE;
01000 LABEL BAD;
01100 PRELOAD_WITH "January", "February", "March", "April", "May", "June",
01200 "July", "August", "September", "October", "November", "December";
01300 STRING ARRAY MONTH[1:12];
01400
01500 STRING PROC TODAY;
01600 BEGIN INTEGER I; I←CALL(0,"DATE");
01700 SETFORMAT(0,0); ⊂ ((year-1964)*12+month-1)*31+day-1;
01800 RETURN(CVS(I MOD 31+1)&" "&MONTH[(I←I%31)MOD 12+1]&CVS(I%12+1964))
01900 END;
02000
02100 PREPARE;
02200 IF (I←ASK("Do you know how to run this program? "))="N" ∨ I="n" THEN BEGIN
02300 UP; DSKI; FILI(INST);
02400 DO SAY(INPUT(INCH,2)) UNTIL EOF;
02500 SAY(CRLF&"This information comes from file "&INST&CRLF&LF);
02600 RELEASE(INCH);
02700 END;
02800
02900 DEFINE URP(S)="BEGIN SAY(S&CRLF); RELEASE(INCH); GO TO BAD END";
03000
03100 BAD:
03200 W←SCALE←0;
03300 IF LN(FILE←ASK("Input file, if any: ")) THEN BEGIN "read"
03400 DSKI; FILI(FILE); IF FLAG THEN URP("""File not found""");
03500 IF EQU(T←TOTAB(S←INLINE),"DATE:") THEN BEGIN
03600 DATE←S; T←TOTAB(S←INLINE);
03700 END;
03800 IF ¬EQU(T,"WINES:") ∨ (W←CVD(S))≤0 ∨ W>WMAX THEN URP("""Wine number error""");
03900 IF ¬EQU(TOTAB(S←INLINE),"SCALE:") ∨ (SCALE←CVD(S))<0 ∨ SCALE>25
04000 THEN URP("""Scale error""");
04100 S←INLINE; ⊂ flush blank line;
04200 END "read"
04300 ELSE BEGIN "ask"
04400 DO W←CVD(ASK("# of wines: ")) UNTIL 0<W≤WMAX;
04500 SCALE←CVD(ASK("SCALE: "));
04600 END;
00100 BEGIN "ARRAYS"
00200 STRING ARRAY WINE[1:W],NOTES[1:W],PEOPLE[1:PMAX];
00300 INTEGER ARRAY YEAR[1:W],SCORE[1:PMAX,1:W],DRINK[1:PMAX,1:W];
00400 INTEGER P,YR; ⊂ PEOPLE COUNTER, CURRENT YEAR;
00500
00600 DEFINE BARF(S)="BEGIN OUTSTR(S&CRLF); RETURN(FALSE) END";
00700
00800 BOOLEAN PROC WININ(INTEGER LOC; STRING WIN); BEGIN
00900 STRING F; INTEGER Y;
01000 IF LN(F←TOTAB(WIN)) THEN BEGIN "CHANGE NAME"
01100 Y←SCAN(F,3,BRK); "FLUSH LEADING SPACES"
01200 IF F="'" THEN F←F[2 TO ∞]
01300 ELSE IF EQU(F[1 FOR 2],"NV") ∨ EQU(F[1 FOR 2],"nv")
01400 THEN F←F[3 TO ∞];
01500 IF F<"0" ∨ F>"9" THEN Y←0
01600 ELSE IF 100≤(Y←INTSCAN(F,BRK))<1800 ∨ Y>YR
01700 THEN BARF("""illegal year""");
01800 YEAR[LOC]← IF Y=0 ∨ Y≥100 THEN Y ELSE IF (Y←Y-YR MOD 100)>0
01900 THEN YR-100+Y ELSE YR+Y;
02000 Y←SCAN(F,3,BRK); "FLUSH SPACES"
02100 WINE[LOC]←F;
02200 END "CHANGE NAME";
02300 IF LN(WIN) THEN NOTES[LOC]←WIN; "STORE NOTES IF NON-NULL"
02400 RETURN(TRUE)
02500 END;
02600
02700 BOOLEAN PROC SCORIN(STRING SC); BEGIN
02800 INTEGER I,J,V;
02900 FOR I ⊃ W DO BEGIN
03000 SCORE[P+1,I]←V←INTSCAN(SC,BRK);
03100 IF V≤0 THEN BARF("IF LN(SC)=0 THEN ""Not enough scores given""
03200 ELSE ""Illegal score of 0""");
03300 IF SCALE=0 ∧ V>W ∨ SCALE ∧ V>SCALE THEN
03400 BARF("CVS(V)&"" is too large""");
03500 IF SCALE=0 THEN FOR J ⊃ I-1 DO IF V=SCORE[P+1,J] THEN
03600 BARF("""Rank ""&CVS(V)&"" duplicated""");
03700 END;
03800 END;
03900
04000 PROC DRINKIN(INTEGER LOC; STRING Y); BEGIN
04100 INTEGER I;
04200 FOR I ⊃ W DO DRINK[LOC,I]←INTSCAN(Y,BRK);
04300 END;
04400
04500 P←0; YR←CALL(0,"DATE")DIV(12*31)+1964; "YR is now the current year"
04600
04700 IF LN(FILE) THEN BEGIN "readmore"
04800 FOR I ⊃ W DO IF ¬WININ(I,S←INLINE) THEN URP(S);
04900 S←INLINE; ⊂ flush blank line;
05000 WHILE LN(S←INLINE) DO BEGIN "people scores"
05100 IF ¬SCORIN(TOTAB(S)) THEN URP("""Rest of line: ""&S");
05200 DRINKIN(P←P+1,TOTAB(S));
05300 IF LN(PEOPLE[P]←S)=0 THEN URP("""Missing TAB or name""");
05400 END "people scores";
05500 RELEASE(INCH);
05600 END "readmore";
05700
00100 WHILE TRUE DO BEGIN "COMMANDS"
00200 INTEGER COM,B; STRING BASE;
00300
00400 STRING PROC WINO(INTEGER L);
00500 RETURN((IF YEAR[L] THEN CVS(YEAR[L]) ELSE " NV ")&" "&WINE[L]);
00600
00700 STRING PROC WINID(INTEGER N);
00800 RETURN(IF LN(BASE) THEN " "&(BASE+N-1) ELSE CVS(B+N));
00900
01000 DEFINE NIX(S)="BEGIN OUTSTR(S&CRLF); RETURN END";
01100
01200 STRING PROC RS; RETURN(IF SCALE THEN "scores" ELSE "ranks");
01300
01400 PROC WINUM; BEGIN
01500 INTEGER I;
01600 SETFORMAT(3,0);
01700 FOR I ⊃ W DO SAY(WINID(I));
01800 SAY(" WINE"&CR);
01900 FOR I ⊃ W DO SAY(" __");
02000 UP END;
02100
02200 PROC HELP; SAY("
02300 COMMANDS:
02400 N - Name wines
02500 P - Print forms
02600 I - Input ratings
02700 T - enter Tasting date
02800 L - List wines
02900 R - show Ratings by person
03000 D - show Distribution of scores
03100 C - show Consensus rank of wines
03200 Y - show drinkable Year by person
03300 A - show All (L,R,D,C,Y)
03400 B - set Base number or letter for wines
03500 F - name File used by W command
03600 W - Write data file
03700 H - Help! show this list
03800
03900 For more complete descriptions of these commands,
04000 list file "&INST&CRLF&LF);
04100
04200 PROC NAME; BEGIN
04300 INTEGER I; STRING S;
04400 SETFORMAT(0,0);
04500 FOR I ⊃ W DO IF LN(S←ASK(WINID(I)&". "&WINO(I)&TAB&NOTES[I]&" "))
04600 THEN WHILE ¬WININ(I,S) DO IF LN(S←ASK("Reenter: "))=0 then done;
04700 END;
04800
04900 PROC PRINT; BEGIN INTEGER I,J,P;
05000 P←CVD(ASK("# OF COPIES: "));
05100 SETFORMAT(4,0);
05200 FOR I ⊃ P DO BEGIN "FORMS"
05300 SAY(CRLF&LF&LF&"Name:"&CRLF&LF&"WINE #:");
05400 FOR J ⊃ W DO SAY(WINID(J));
05500 SAY(CRLF&LF&RS&":"&CRLF&LF&"Years:"&CRLF&LF&LF);
05600 END "FORMS"
05700 END "PRINT";
05800
05900 PROC INPUT; BEGIN
06000 STRING NAM,S; INTEGER PC,I;
06100 SETFORMAT(0,0);
06200 WHILE LN(S←ASK("name: ")) DO BEGIN "ENTER SCORES"
06300 IF S≠"." THEN NAM←S
06400 ELSE IF LN(NAM) THEN SAY(TAB&NAM&CRLF) ELSE RETURN;
06500 FOR PC ⊃ P DO IF EQU(NAM,PEOPLE[PC]) THEN
06600 BEGIN SAY("So you've changed your mind, eh?"&CRLF); DONE END;
06700 IF PC>PMAX THEN NIX("""Sorry, no more room""");
06800 IF LN(S←ASK(RS&": ")) ∧ SCORIN(S) THEN BEGIN
06900 IF PC>P THEN PEOPLE[P←PC]←NAM
07000 ELSE FOR I ⊃ W DO SCORE[PC,I]←SCORE[P+1,I];
07100 DRINKIN(PC,ASK("Year to drink: "));
07200 END;
07300 END "ENTER SCORES"
07400 END "INPUT";
07500
07600 PROC WRITE; BEGIN
07700 INTEGER I,J;
07800 SETFORMAT(0,0);
07900 DSKO; FILO(FILE); IF FLAG THEN BEGIN
08000 SAY("File "&FILE&" cannot be written"&CRLF);
08100 RELEASE(OUCH); RETURN
08200 END;
08300 OUT(OUCH,"DATE: "&(IF LN(DATE) THEN DATE ELSE TODAY)&CRLF);
08400 OUT(OUCH,"WINES: "&CVS(W)&CRLF);
08500 OUT(OUCH,"SCALE: "&CVS(SCALE)&CRLF&CRLF);
08600 FOR I ⊃ W DO OUT(OUCH,WINO(I)&TAB&NOTES[I]&CRLF);
08700 OUT(OUCH,CRLF); SETFORMAT(3,0);
08800 FOR I ⊃ P DO BEGIN
08900 FOR J ⊃ W DO OUT(OUCH,CVS(SCORE[I,J]));
09000 OUT(OUCH,TAB);
09100 FOR J ⊃ W DO OUT(OUCH,CVS(DRINK[I,J])&" ");
09200 OUT(OUCH,TAB&PEOPLE[I]&CRLF);
09300 END;
09400 RELEASE(OUCH);
09500 END;
09600
09700 PROC LIST; BEGIN
09800 INTEGER I;
09900 IF LN(DATE) THEN SAY(LF&"Tasting of "&DATE&CRLF&LF);
10000 SETFORMAT(0,0);
10100 FOR I ⊃ W DO SAY(WINID(I)&". "&WINO(I)&CRLF);
10200 UP END;
10300
10400 PROC RATINGS; BEGIN
10500 INTEGER I,J;
10600 SETFORMAT(0,0);
10700 SAY(CRLF&RS&" by person"&(IF SCALE THEN " (Scale of "&CVS(SCALE)&")"
10800 ELSE NULL)&CRLF&LF);
10900 WINUM;
11000 FOR I ⊃ P DO BEGIN
11100 FOR J ⊃ W DO SAY(CVS(SCORE[I,J]));
11200 SAY(" "&PEOPLE[I]&CRLF);
11300 END;
11400 UP END "RATINGS";
11500
11600 PROC DISTRIBUTION; BEGIN
11700 INTEGER I,J,N,M;
11800 INTEGER ARRAY DIST[1:M←(IF SCALE THEN SCALE ELSE W)];
11900 SETFORMAT(3,0); SAY(CRLF&"Distribution of "&RS&CRLF&LF);
12000 FOR I ⊃ M DO SAY(CVS(I)); SAY(CR);
12100 FOR I ⊃ M DO SAY(" __"); UP;
12200 FOR I ⊃ W DO BEGIN
12300 FOR J ⊃ M DO DIST[J]←0;
12400 FOR J ⊃ P DO BEGIN
12500 N←SCORE[J,I];
12600 DIST[N]←DIST[N]+1;
12700 END;
12800 FOR J ⊃ M DO SAY(CVS(DIST[J]));
12900 SAY(WINID(I)&". "&WINO(I)&CRLF);
13000 END;
13100 UP END "DISTRIBUTION";
13200
13300 PROC CONSENSUS; IF P>0 THEN BEGIN "CONS"
13400 INTEGER I,J,K,N,N2,MN,MX; REAL M;
13500 INTEGER ARRAY ORDER,MINI,MAXI,SQUARES[1:W];
13600 EXTERNAL FORTRAN REAL PROC SQRT(REAL N);
13700 SAY(CRLF&"consensus "&RS&CRLF&
13800 "mean dev min max #"&CR&"____ ____ ___ ___"&CRLF);
13900 FOR I ⊃ W DO BEGIN
14000 N←MN←MX←SCORE[1,I];
14100 N2←N*N;
14200 FOR J←2 THRU P DO BEGIN
14300 N←N+(K←SCORE[J,I]);
14400 N2←N2+K*K;
14500 MN←MN MIN K;
14600 MX←MX MAX K;
14700 END;
14800 ORDER[I]←IF SCALE THEN N ELSE -N;
14900 MINI[I]←MN; MAXI[I]←MX; SQUARES[I]←N2;
15000 END;
15100 SETFORMAT(2,1);
15200 FOR I ⊃ W DO BEGIN "RANK"
15300 N←1;
15400 FOR J←2 THRU W DO IF ORDER[J]>ORDER[N] THEN N←J;
15500 SAY(CVF(M←ABS ORDER[N]/P)&
15600 RIGHT(5,CVF(SQRT((SQUARES[N]-M*ABS ORDER[N])/(P-1))))&
15700 " "&CVS(MINI[N])&" "&CVS(MAXI[N])&" "&WINID(N)&". "&WINO(N)&CRLF);
15800 ORDER[N]←-1000000; "DELETE IT"
15900 END "RANK";
16000 UP END "CONS";
16100
16200 PROC YEARS; BEGIN
16300 INTEGER I,J,T,M,SUM;
16400 STRING S;
16500 SAY(CRLF&"Estimated year when drinkable"&CRLF&LF);
16600 WINUM;
16700 FOR I ⊃ P DO BEGIN "BY PEOPLE"
16800 S←NULL; M←0;
16900 FOR J ⊃ W DO IF (T←DRINK[I,J]) THEN
17000 BEGIN M←M+T; S←S&CVS(T); END
17100 ELSE S←S&" ";
17200 IF M THEN SAY(S&" "&PEOPLE[I]&CRLF);
17300 END;
17400 UP;
17500 FOR I ⊃ W DO BEGIN "EARLIEST"
17600 M←99999;
17700 FOR J ⊃ P DO IF (T←DRINK[J,I]) ∧ T<M THEN M←T;
17800 SAY(IF M<99999 THEN CVS(M) ELSE " ");
17900 END;
18000 SAY(" earliest"&CRLF);
18100 FOR I ⊃ W DO BEGIN "LATEST"
18200 M←0;
18300 FOR J ⊃ P DO M←M MAX DRINK[J,I];
18400 SAY(IF M THEN CVS(M) ELSE " ");
18500 END;
18600 SAY(" latest"&CRLF);
18700 FOR I ⊃ W DO BEGIN "MEAN"
18800 SUM←M←0;
18900 FOR J ⊃ P DO IF (T←DRINK[J,I]) THEN
19000 BEGIN SUM←SUM+T; M←M+1; END;
19100 SAY(IF M THEN CVS((SUM+M%2)%M) ELSE " ");
19200 END;
19300 SAY(" mean"&CRLF&LF);
19400 END "YEARS";
19500
19600 IF LN(S←ASK("*"))=1 THEN BEGIN "DECODE"
19700 IF (COM←S LAND '137)>"I" THEN BEGIN
19800 IF COM="N" THEN NAME ELSE IF COM="W" THEN WRITE
19900 ELSE IF COM="L" THEN LIST ELSE IF COM="P" THEN PRINT
20000 ELSE IF COM="R" THEN RATINGS ELSE IF COM="T" THEN
20100 BEGIN IF LN(S←ASK("Tasting date: ")) THEN DATE←S END
20200 ELSE IF COM ="Y" THEN YEARS
20300 END
20400 ELSE IF (COM←COM-"A")≥0 THEN CASE COM OF BEGIN
20500 BEGIN LIST; RATINGS; DISTRIBUTION; CONSENSUS; YEARS END; "A"
20600 IF 0≤(BASE←ASK("Base number or letter: "))≤"9" THEN
20700 BEGIN B←CVD(BASE)-1; BASE←NULL END
20800 ELSE B←0; "B"
20900 CONSENSUS; "C"
21000 DISTRIBUTION; "D"
21100 ;
21200 IF LN(S←ASK("Output file: ")) THEN FILE←S; "F"
21300 ;
21400 HELP; "H"
21500 INPUT
21600 END
21700 END "DECODE"
21800 END "COMMANDS"
21900 END "ARRAYS"
22000 END